home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / graphics.swg / 0079_Shade Bobs.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-01-27  |  3.2 KB  |  132 lines
  1. {
  2. >> 1. Scrolling 256c fonts Fast and Smooth.
  3. >> 2. Now to do it on top of graphics...
  4. >> 3. 3D object engine - If someone can post me one or direct me
  5. >> to build one.
  6. >> 4. Shade Bobs/Whatever it called - Taking a shape and moving it
  7. >> across the screen when it leaves trail.  Then, moving again
  8. >> on the trail will couse a stronger color to appear. n' on...
  9. >> 5. Moving floor that is NOT a couse of a palette rotetion.
  10. >> 6. 2D Scale procedure.
  11. >> 7. Centered Stars. And SMOOTH ones.
  12. >> 8. Vector Balls
  13.  
  14. I don't want to give it all away, but I just made some Shaded-bobs (or
  15. whatever). It realy isn't difficult. It worked right away. Now YOU make a nicer
  16. sin-curve and palette. Here's some source:
  17. }
  18.  
  19. {$G+}
  20.  
  21. program ShadingBobs;
  22. const
  23.   Gseg : word = $a000;
  24.   Sofs = 75; Samp = 75; Slen = 255;
  25.   SprPic : array[0..15,0..15] of byte = (
  26.     (0,0,0,0,0,0,1,1,1,1,0,0,0,0,0,0),
  27.     (0,0,0,0,1,1,1,1,1,1,1,1,0,0,0,0),
  28.     (0,0,0,1,1,1,1,1,1,1,1,1,1,0,0,0),
  29.     (0,0,1,1,1,1,1,2,2,1,1,1,1,1,0,0),
  30.     (0,1,1,1,1,1,2,2,2,2,1,1,1,1,1,0),
  31.     (0,1,1,1,1,2,2,3,3,2,2,1,1,1,1,0),
  32.     (1,1,1,1,2,2,3,3,3,3,2,2,1,1,1,1),
  33.     (1,1,1,1,2,2,3,4,4,3,2,2,1,1,1,1),
  34.     (1,1,1,1,2,2,3,3,3,3,2,2,1,1,1,1),
  35.     (0,1,1,1,1,2,2,3,3,2,2,1,1,1,1,0),
  36.     (0,1,1,1,1,1,2,2,2,2,1,1,1,1,1,0),
  37.     (0,0,1,1,1,1,1,2,2,1,1,1,1,1,0,0),
  38.     (0,0,1,1,1,1,1,1,1,1,1,1,1,1,0,0),
  39.     (0,0,0,1,1,1,1,1,1,1,1,1,1,0,0,0),
  40.     (0,0,0,0,1,1,1,1,1,1,1,1,0,0,0,0),
  41.     (0,0,0,0,0,0,1,1,1,1,0,0,0,0,0,0));
  42. type SinArray = array[0..Slen] of word;
  43. var Stab : SinArray;
  44.  
  45. procedure CalcSinus; var I : word; begin
  46.   for I := 0 to Slen do Stab[I] := round(sin(I*4*pi/Slen)*Samp)+Sofs; end;
  47.  
  48. procedure SetGraphics(Mode : word); assembler; asm
  49.   mov ax,Mode; int 10h end;
  50.  
  51. function keypressed : boolean; assembler; asm
  52.   mov ah,0bh; int 21h; and al,0feh; end;
  53.  
  54. procedure DrawSprite(X,Y : integer; W,H : byte; Sprite : pointer); assembler;
  55. asm
  56.   push ds
  57.   lds si,[Sprite]
  58.   mov es,Gseg
  59.   cld
  60.   mov ax,[Y]
  61.   shl ax,6
  62.   mov di,ax
  63.   shl ax,2
  64.   add di,ax
  65.   add di,[X]
  66.   mov bh,[H]
  67.   mov cx,320
  68.   sub cl,[W]
  69.   sbb ch,0
  70.  @L:
  71.   mov bl,[W]
  72.  @L2:
  73.   lodsb
  74.   or al,al
  75.   jz @S
  76.   mov dl,[es:di]
  77.   add dl,al
  78.   mov [es:di],dl
  79.  @S:
  80.   inc di
  81.   dec bl
  82.   jnz @L2
  83.   add di,cx
  84.   dec bh
  85.   jnz @L
  86.   pop ds
  87. end;
  88.  
  89. procedure Retrace; assembler; asm
  90.   mov dx,3dah;
  91.   @l1: in al,dx; test al,8; jnz @l1;
  92.   @l2: in al,dx; test al,8; jz @l2; end;
  93.  
  94. procedure Setpalette;
  95. var I : byte;
  96. begin
  97.   for I := 0 to 255 do begin
  98.     port[$3c8] := I;
  99.     port[$3c9] := I div 3;
  100.     port[$3c9] := I div 2;
  101.     port[$3c9] := I;
  102.   end;
  103. end;
  104.  
  105. procedure Bobs;
  106. var X,Y : integer; I,J : byte;
  107. begin
  108.   I := 0; J := 25;
  109.   repeat
  110.     X := 2*Stab[I]; Y := Stab[J];
  111.     inc(I); inc(J);
  112.     Retrace;
  113.     DrawSprite(X,Y,16,16,addr(SprPic));
  114.   until keypressed;
  115. end;
  116.  
  117. begin
  118.   CalcSinus;
  119.   SetGraphics($13);
  120. {  SetPalette;}
  121.   Bobs;
  122.   SetGraphics(3);
  123. end.
  124.  
  125. { DrawSprite procedure taken from Sean Palmer (again).
  126.   It contained some minor bugs: [X] was added to AX, should be DI, and
  127.   jz @S was jnz @S, so the sprite wasn't drawn. Now it is...
  128.   And of course it was changed to INCREASE the video-mem, not to poke it.
  129.  
  130.   If you get rid of the Retrace it goes a LOT faster. }
  131.  
  132.